From aceb379beb509960bfec376b22c4b342f1236ab7 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Thu, 20 Feb 2014 20:32:11 -0800 Subject: [PATCH] Improve dbus error handling; detect bus failure --- lisp/ChangeLog | 15 ++++++ lisp/net/dbus.el | 123 ++++++++++++++++++++++++++++++++++++++--------- src/ChangeLog | 4 ++ src/dbusbind.c | 11 +++-- 4 files changed, 125 insertions(+), 28 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 2efc60f4840..154fd6ba235 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,18 @@ +2014-02-21 Daniel Colascione + + * net/dbus.el (dbus-init-bus-1): Declare new subr. + (dbus-init-bus): New function: call into dbus-init-bus-1 + and installs a handler for the disconnect signal. + (dbus-call-method): Rewrite to look for result in cons. + (dbus-call-method-handler): Store result in cons. + (dbus-check-event): Recognize events with nil sender as valid. + (dbus-handle-bus-disconnect): New function. React to bus + disconnection signal by synthesizing dbus error for each + pending synchronous or asynchronous call. + (dbus-notice-synchronous-call-errors): New function. + (dbus-handle-event): Raise errors directly only when `dbus-debug' + is true, not all the time. + 2014-02-20 Michael Albinus * net/tramp.el (ls-lisp-use-insert-directory-program): Declare. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 5c1296de1fa..900bf4302b5 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -35,7 +35,7 @@ ;; Declare used subroutines and variables. (declare-function dbus-message-internal "dbusbind.c") -(declare-function dbus-init-bus "dbusbind.c") +(declare-function dbus-init-bus-1 "dbusbind.c") (defvar dbus-message-type-invalid) (defvar dbus-message-type-method-call) (defvar dbus-message-type-method-return) @@ -154,7 +154,7 @@ Otherwise, return result of last form in BODY, or all other errors." (define-obsolete-variable-alias 'dbus-event-error-hooks 'dbus-event-error-functions "24.3") -(defvar dbus-event-error-functions nil +(defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors) "Functions to be called when a D-Bus error happens in the event handler. Every function must accept two arguments, the event and the error variable caught in `condition-case' by `dbus-error'.") @@ -173,11 +173,23 @@ SERIAL is the serial number of the reply message.") "Handler for reply messages of asynchronous D-Bus message calls. It calls the function stored in `dbus-registered-objects-table'. The result will be made available in `dbus-return-values-table'." - (puthash (list :serial - (dbus-event-bus-name last-input-event) - (dbus-event-serial-number last-input-event)) - (if (= (length args) 1) (car args) args) - dbus-return-values-table)) + (let* ((key (list :serial + (dbus-event-bus-name last-input-event) + (dbus-event-serial-number last-input-event))) + (result (gethash key dbus-return-values-table))) + (when (consp result) + (setcar result :complete) + (setcdr result (if (= (length args) 1) (car args) args))))) + +(defun dbus-notice-synchronous-call-errors (ev er) + "Detect errors resulting from pending synchronous calls." + (let* ((key (list :serial + (dbus-event-bus-name ev) + (dbus-event-serial-number ev))) + (result (gethash key dbus-return-values-table))) + (when (consp result) + (setcar result :error) + (setcdr result er)))) (defun dbus-call-method (bus service path interface method &rest args) "Call METHOD on the D-Bus BUS. @@ -264,7 +276,8 @@ object is returned instead of a list containing this single Lisp object. (key (apply 'dbus-message-internal dbus-message-type-method-call - bus service path interface method 'dbus-call-method-handler args))) + bus service path interface method 'dbus-call-method-handler args)) + (result (cons :pending nil))) ;; Wait until `dbus-call-method-handler' has put the result into ;; `dbus-return-values-table'. If no timeout is given, use the @@ -278,20 +291,23 @@ object is returned instead of a list containing this single Lisp object. ;; restructuring dbus as a kind of process object. Poll at most ;; about once per second for completion. - (with-timeout ((if timeout (/ timeout 1000.0) 25)) - (while (eq (gethash key dbus-return-values-table :ignore) :ignore) - (let ((event (let ((inhibit-redisplay t) unread-command-events) - (read-event nil nil check-interval)))) - (when event - (setf unread-command-events - (nconc unread-command-events - (cons event nil)))) - (when (< check-interval 1) - (setf check-interval (* check-interval 1.05)))))) - - ;; Cleanup `dbus-return-values-table'. Return the result. - (prog1 - (gethash key dbus-return-values-table) + (puthash key result dbus-return-values-table) + (unwind-protect + (progn + (with-timeout ((if timeout (/ timeout 1000.0) 25) + (signal 'dbus-error (list "call timed out"))) + (while (eq (car result) :pending) + (let ((event (let ((inhibit-redisplay t) unread-command-events) + (read-event nil nil check-interval)))) + (when event + (setf unread-command-events + (nconc unread-command-events + (cons event nil)))) + (when (< check-interval 1) + (setf check-interval (* check-interval 1.05)))))) + (when (eq (car result) :error) + (signal (cadr result) (cddr result))) + (cdr result)) (remhash key dbus-return-values-table)))) ;; `dbus-call-method' works non-blocking now. @@ -922,7 +938,8 @@ not well formed." ;; Service. (or (= dbus-message-type-method-return (nth 2 event)) (= dbus-message-type-error (nth 2 event)) - (stringp (nth 4 event))) + (or (stringp (nth 4 event)) + (null (nth 4 event)))) ;; Object path. (or (= dbus-message-type-method-return (nth 2 event)) (= dbus-message-type-error (nth 2 event)) @@ -973,7 +990,7 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." (nth 1 event) (nth 4 event) (nth 3 event) (cadr err)))) ;; Propagate D-Bus error messages. (run-hook-with-args 'dbus-event-error-functions event err) - (when (or dbus-debug (= dbus-message-type-error (nth 2 event))) + (when dbus-debug (signal (car err) (cdr err)))))) (defun dbus-event-bus-name (event) @@ -1679,6 +1696,64 @@ It will be registered for all objects created by `dbus-register-method'." result) '(:signature "{oa{sa{sv}}}")))))) +(defun dbus-handle-bus-disconnect () + "React to a bus disconnection. +BUS is the bus that disconnected. This routine unregisters all +handlers on the given bus and causes all synchronous calls +pending at the time of disconnect to fail." + (let ((bus (dbus-event-bus-name last-input-event)) + (keys-to-remove)) + (maphash + (lambda (key value) + (when (and (eq (nth 0 key) :serial) + (eq (nth 1 key) bus)) + (run-hook-with-args + 'dbus-event-error-functions + (list 'dbus-event + bus + dbus-message-type-error + (nth 2 key) + nil + nil + nil + nil + value) + '(dbus-error "Bus disconnected")) + (push key keys-to-remove))) + dbus-registered-objects-table) + (dolist (key keys-to-remove) + (remhash key dbus-registered-objects-table)))) + +(defun dbus-init-bus (bus &optional private) + "Establish the connection to D-Bus BUS. + +BUS can be either the symbol `:system' or the symbol `:session', or it +can be a string denoting the address of the corresponding bus. For +the system and session buses, this function is called when loading +`dbus.el', there is no need to call it again. + +The function returns a number, which counts the connections this Emacs +session has established to the BUS under the same unique name (see +`dbus-get-unique-name'). It depends on the libraries Emacs is linked +with, and on the environment Emacs is running. For example, if Emacs +is linked with the gtk toolkit, and it runs in a GTK-aware environment +like Gnome, another connection might already be established. + +When PRIVATE is non-nil, a new connection is established instead of +reusing an existing one. It results in a new unique name at the bus. +This can be used, if it is necessary to distinguish from another +connection used in the same Emacs process, like the one established by +GTK+. It should be used with care for at least the `:system' and +`:session' buses, because other Emacs Lisp packages might already use +this connection to those buses. +" + (dbus-init-bus-1 bus private) + (dbus-register-signal bus nil + "/org/freedesktop/DBus/Local" + "org.freedesktop.DBus.Local" + "Disconnected" + #'dbus-handle-bus-disconnect)) + ;; Initialize `:system' and `:session' buses. This adds their file ;; descriptors to input_wait_mask, in order to detect incoming diff --git a/src/ChangeLog b/src/ChangeLog index 0861d4c2c1a..82bdd127d26 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,7 @@ +2014-02-21 Daniel Colascione + + * dbusbind.c: Rename dbus-init-bus to dbus-init-bus-1. + 2014-02-20 Eli Zaretskii * xdisp.c (init_iterator): Don't dereference a bogus face diff --git a/src/dbusbind.c b/src/dbusbind.c index 1c386f02c90..460733c7239 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -42,7 +42,7 @@ along with GNU Emacs. If not, see . */ /* Subroutines. */ -static Lisp_Object Qdbus_init_bus; +static Lisp_Object Qdbus_init_bus_1; static Lisp_Object Qdbus_get_unique_name; static Lisp_Object Qdbus_message_internal; @@ -1121,9 +1121,12 @@ xd_close_bus (Lisp_Object bus) return; } -DEFUN ("dbus-init-bus", Fdbus_init_bus, Sdbus_init_bus, 1, 2, 0, +DEFUN ("dbus-init-bus-1", Fdbus_init_bus_1, Sdbus_init_bus_1, 1, 2, 0, doc: /* Establish the connection to D-Bus BUS. +This function is dbus-internal. You almost certainly want to use +dbus-init-bus. + BUS can be either the symbol `:system' or the symbol `:session', or it can be a string denoting the address of the corresponding bus. For the system and session buses, this function is called when loading @@ -1742,8 +1745,8 @@ void syms_of_dbusbind (void) { - DEFSYM (Qdbus_init_bus, "dbus-init-bus"); - defsubr (&Sdbus_init_bus); + DEFSYM (Qdbus_init_bus_1, "dbus-init-bus-1"); + defsubr (&Sdbus_init_bus_1); DEFSYM (Qdbus_get_unique_name, "dbus-get-unique-name"); defsubr (&Sdbus_get_unique_name); -- 2.30.2